home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / Mac_F2C_1.3.2.sit / Mac F2C 1.3.2 / Mac F2C Libraries / libI77 Sources / rsne.c < prev    next >
C/C++ Source or Header  |  1995-01-28  |  11KB  |  569 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "lio.h"
  4.  
  5. #define MAX_NL_CACHE 3    /* maximum number of namelist hash tables to cache */
  6. #define MAXDIM 20    /* maximum number of subscripts */
  7.  
  8.  struct dimen {
  9.     ftnlen extent;
  10.     ftnlen curval;
  11.     ftnlen delta;
  12.     ftnlen stride;
  13.     };
  14.  typedef struct dimen dimen;
  15.  
  16.  struct hashentry {
  17.     struct hashentry *next;
  18.     char *name;
  19.     Vardesc *vd;
  20.     };
  21.  typedef struct hashentry hashentry;
  22.  
  23.  struct hashtab {
  24.     struct hashtab *next;
  25.     Namelist *nl;
  26.     int htsize;
  27.     hashentry *tab[1];
  28.     };
  29.  typedef struct hashtab hashtab;
  30.  
  31.  static hashtab *nl_cache;
  32.  static n_nlcache;
  33.  static hashentry **zot;
  34.  extern ftnlen f__typesize[];
  35.  
  36.  extern flag f__lquit;
  37.  extern int f__lcount, nml_read;
  38.  extern t_getc(Void);
  39.  
  40. #ifdef KR_headers
  41.  extern char *malloc(), *memset();
  42.  
  43. #ifdef ungetc
  44.  static int
  45. un_getc(x,f__cf) int x; FILE *f__cf;
  46. { return ungetc(x,f__cf); }
  47. #else
  48. #define un_getc ungetc
  49.  extern int ungetc();
  50. #endif
  51.  
  52. #else
  53. #undef abs
  54. #undef min
  55. #undef max
  56. #include "stdlib.h"
  57. #include "string.h"
  58.  
  59. #ifdef ungetc
  60.  static int
  61. un_getc(int x, FILE *f__cf)
  62. { return ungetc(x,f__cf); }
  63. #else
  64. #define un_getc ungetc
  65. extern int ungetc(int, FILE*);    /* for systems with a buggy stdio.h */
  66. #endif
  67. #endif
  68.  
  69.  static Vardesc *
  70. #ifdef KR_headers
  71. hash(ht, s) hashtab *ht; register char *s;
  72. #else
  73. hash(hashtab *ht, register char *s)
  74. #endif
  75. {
  76.     register int c, x;
  77.     register hashentry *h;
  78.     char *s0 = s;
  79.  
  80.     for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
  81.         x += c;
  82.     for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
  83.         if (!strcmp(s0, h->name))
  84.             return h->vd;
  85.     return 0;
  86.     }
  87.  
  88.  hashtab *
  89. #ifdef KR_headers
  90. mk_hashtab(nl) Namelist *nl;
  91. #else
  92. mk_hashtab(Namelist *nl)
  93. #endif
  94. {
  95.     int nht, nv;
  96.     hashtab *ht;
  97.     Vardesc *v, **vd, **vde;
  98.     hashentry *he;
  99.  
  100.     hashtab **x, **x0, *y;
  101.     for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
  102.         if (nl == y->nl)
  103.             return y;
  104.     if (n_nlcache >= MAX_NL_CACHE) {
  105.         /* discard least recently used namelist hash table */
  106.         y = *x0;
  107.         free((char *)y->next);
  108.         y->next = 0;
  109.         }
  110.     else
  111.         n_nlcache++;
  112.     nv = nl->nvars;
  113.     if (nv >= 0x4000)
  114.         nht = 0x7fff;
  115.     else {
  116.         for(nht = 1; nht < nv; nht <<= 1);
  117.         nht += nht - 1;
  118.         }
  119.     ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
  120.                 + nv*sizeof(hashentry));
  121.     if (!ht)
  122.         return 0;
  123.     he = (hashentry *)&ht->tab[nht];
  124.     ht->nl = nl;
  125.     ht->htsize = nht;
  126.     ht->next = nl_cache;
  127.     nl_cache = ht;
  128.     memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
  129.     vd = nl->vars;
  130.     vde = vd + nv;
  131.     while(vd < vde) {
  132.         v = *vd++;
  133.         if (!hash(ht, v->name)) {
  134.             he->next = *zot;
  135.             *zot = he;
  136.             he->name = v->name;
  137.             he->vd = v;
  138.             he++;
  139.             }
  140.         }
  141.     return ht;
  142.     }
  143.  
  144. static char Alpha[256], Alphanum[256];
  145.  
  146.  static VOID
  147. nl_init(Void) {
  148.     register char *s;
  149.     register int c;
  150.  
  151.     if(!f__init)
  152.         f_init();
  153.     for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
  154.         Alpha[c]
  155.         = Alphanum[c]
  156.         = Alpha[c + 'a' - 'A']
  157.         = Alphanum[c + 'a' - 'A']
  158.         = c;
  159.     for(s = "0123456789_"; c = *s++; )
  160.         Alphanum[c] = c;
  161.     }
  162.  
  163. #define GETC(x) (x=(*l_getc)())
  164. #define Ungetc(x,y) (*l_ungetc)(x,y)
  165.  
  166.  static int
  167. #ifdef KR_headers
  168. getname(s, slen) register char *s; int slen;
  169. #else
  170. getname(register char *s, int slen)
  171. #endif
  172. {
  173.     register char *se = s + slen - 1;
  174.     register int ch;
  175.  
  176.     GETC(ch);
  177.     if (!(*s++ = Alpha[ch & 0xff])) {
  178.         if (ch != EOF)
  179.             ch = 115;
  180.         errfl(f__elist->cierr, ch, "namelist read");
  181.         }
  182.     while(*s = Alphanum[GETC(ch) & 0xff])
  183.         if (s < se)
  184.             s++;
  185.     if (ch == EOF)
  186.         err(f__elist->cierr, EOF, "namelist read");
  187.     if (ch > ' ')
  188.         Ungetc(ch,f__cf);
  189.     return *s = 0;
  190.     }
  191.  
  192.  static int
  193. #ifdef KR_headers
  194. getnum(chp, val) int *chp; ftnlen *val;
  195. #else
  196. getnum(int *chp, ftnlen *val)
  197. #endif
  198. {
  199.     register int ch, sign;
  200.     register ftnlen x;
  201.  
  202.     while(GETC(ch) <= ' ' && ch >= 0);
  203.     if (ch == '-') {
  204.         sign = 1;
  205.         GETC(ch);
  206.         }
  207.     else {
  208.         sign = 0;
  209.         if (ch == '+')
  210.             GETC(ch);
  211.         }
  212.     x = ch - '0';
  213.     if (x < 0 || x > 9)
  214.         return 115;
  215.     while(GETC(ch) >= '0' && ch <= '9')
  216.         x = 10*x + ch - '0';
  217.     while(ch <= ' ' && ch >= 0)
  218.         GETC(ch);
  219.     if (ch == EOF)
  220.         return EOF;
  221.     *val = sign ? -x : x;
  222.     *chp = ch;
  223.     return 0;
  224.     }
  225.  
  226.  static int
  227. #ifdef KR_headers
  228. getdimen(chp, d, delta, extent, x1)
  229.  int *chp; dimen *d; ftnlen delta, extent, *x1;
  230. #else
  231. getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
  232. #endif
  233. {
  234.     register int k;
  235.     ftnlen x2, x3;
  236.  
  237.     if (k = getnum(chp, x1))
  238.         return k;
  239.     x3 = 1;
  240.     if (*chp == ':') {
  241.         if (k = getnum(chp, &x2))
  242.             return k;
  243.         x2 -= *x1;
  244.         if (*chp == ':') {
  245.             if (k = getnum(chp, &x3))
  246.                 return k;
  247.             if (!x3)
  248.                 return 123;
  249.             x2 /= x3;
  250.             }
  251.         if (x2 < 0 || x2 >= extent)
  252.             return 123;
  253.         d->extent = x2 + 1;
  254.         }
  255.     else
  256.         d->extent = 1;
  257.     d->curval = 0;
  258.     d->delta = delta;
  259.     d->stride = x3;
  260.     return 0;
  261.     }
  262.  
  263. #ifndef No_Namelist_Questions
  264.  static Void
  265. #ifdef KR_headers
  266. print_ne(a) cilist *a;
  267. #else
  268. print_ne(cilist *a)
  269. #endif
  270. {
  271.     flag intext = f__external;
  272.     int rpsave = f__recpos;
  273.     FILE *cfsave = f__cf;
  274.     unit *usave = f__curunit;
  275.     cilist t;
  276.     t = *a;
  277.     t.ciunit = 6;
  278.     s_wsne(&t);
  279.     fflush(f__cf);
  280.     f__external = intext;
  281.     f__reading = 1;
  282.     f__recpos = rpsave;
  283.     f__cf = cfsave;
  284.     f__curunit = usave;
  285.     f__elist = a;
  286.     }
  287. #endif
  288.  
  289.  static char where0[] = "namelist read start ";
  290.  
  291. #ifdef KR_headers
  292. x_rsne(a) cilist *a;
  293. #else
  294. x_rsne(cilist *a)
  295. #endif
  296. {
  297.     int ch, got1, k, n, nd, quote;
  298.     Namelist *nl;
  299.     static char where[] = "namelist read";
  300.     char buf[64];
  301.     hashtab *ht;
  302.     Vardesc *v;
  303.     dimen *dn, *dn0, *dn1;
  304.     ftnlen *dims, *dims1;
  305.     ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
  306.     ftnint type;
  307.     char *vaddr;
  308.     long iva, ivae;
  309.     dimen dimens[MAXDIM], substr;
  310.  
  311.     if (!Alpha['a'])
  312.         nl_init();
  313.     f__reading=1;
  314.     f__formatted=1;
  315.     got1 = 0;
  316.  top:
  317.     for(;;) switch(GETC(ch)) {
  318.         case EOF:
  319.             err(a->ciend,(EOF),where0);
  320.         case '&':
  321.         case '$':
  322.             goto have_amp;
  323. #ifndef No_Namelist_Questions
  324.         case '?':
  325.             print_ne(a);
  326.             continue;
  327. #endif
  328.         default:
  329.             if (ch <= ' ' && ch >= 0)
  330.                 continue;
  331.             errfl(a->cierr, 115, where0);
  332.         }
  333.  have_amp:
  334.     if (ch = getname(buf,sizeof(buf)))
  335.         return ch;
  336.     nl = (Namelist *)a->cifmt;
  337.     if (strcmp(buf, nl->name))
  338. #ifdef No_Bad_Namelist_Skip
  339.         errfl(a->cierr, 118, where0);
  340. #else
  341.     {
  342.         fprintf(stderr,
  343.             "Skipping namelist ¥"%s¥": seeking namelist ¥"%s¥".¥n",
  344.             buf, nl->name);
  345.         fflush(stderr);
  346.         for(;;) switch(GETC(ch)) {
  347.             case EOF:
  348.                 err(a->ciend, EOF, where0);
  349.             case '/':
  350.             case '&':
  351.             case '$':
  352.                 if (f__external)
  353.                     e_rsle();
  354.                 else
  355.                     z_rnew();
  356.                 goto top;
  357.             case '"':
  358.             case '¥'':
  359.                 quote = ch;
  360.  more_quoted:
  361.                 while(GETC(ch) != quote)
  362.                     if (ch == EOF)
  363.                         err(a->ciend, EOF, where0);
  364.                 if (GETC(ch) == quote)
  365.                     goto more_quoted;
  366.                 Ungetc(ch,f__cf);
  367.             default:
  368.                 continue;
  369.             }
  370.         }
  371. #endif
  372.     ht = mk_hashtab(nl);
  373.     if (!ht)
  374.         errfl(f__elist->cierr, 113, where0);
  375.     for(;;) {
  376.         for(;;) switch(GETC(ch)) {
  377.             case EOF:
  378.                 if (got1)
  379.                     return 0;
  380.                 err(a->ciend, EOF, where0);
  381.             case '/':
  382.             case '$':
  383.             case '&':
  384.                 return 0;
  385.             default:
  386.                 if (ch <= ' ' && ch >= 0 || ch == ',')
  387.                     continue;
  388.                 Ungetc(ch,f__cf);
  389.                 if (ch = getname(buf,sizeof(buf)))
  390.                     return ch;
  391.                 goto havename;
  392.             }
  393.  havename:
  394.         v = hash(ht,buf);
  395.         if (!v)
  396.             errfl(a->cierr, 119, where);
  397.         while(GETC(ch) <= ' ' && ch >= 0);
  398.         vaddr = v->addr;
  399.         type = v->type;
  400.         if (type < 0) {
  401.             size = -type;
  402.             type = TYCHAR;
  403.             }
  404.         else
  405.             size = f__typesize[type];
  406.         ivae = size;
  407.         iva = 0;
  408.         if (ch == '(' /*)*/ ) {
  409.             dn = dimens;
  410.             if (!(dims = v->dims)) {
  411.                 if (type != TYCHAR)
  412.                     errfl(a->cierr, 122, where);
  413.                 if (k = getdimen(&ch, dn, (ftnlen)size,
  414.                         (ftnlen)size, &b))
  415.                     errfl(a->cierr, k, where);
  416.                 if (ch != ')')
  417.                     errfl(a->cierr, 115, where);
  418.                 b1 = dn->extent;
  419.                 if (--b < 0 || b + b1 > size)
  420.                     return 124;
  421.                 iva += b;
  422.                 size = b1;
  423.                 while(GETC(ch) <= ' ' && ch >= 0);
  424.                 goto scalar;
  425.                 }
  426.             nd = (int)dims[0];
  427.             nomax = span = dims[1];
  428.             ivae = iva + size*nomax;
  429.             if (k = getdimen(&ch, dn, size, nomax, &b))
  430.                 errfl(a->cierr, k, where);
  431.             no = dn->extent;
  432.             b0 = dims[2];
  433.             dims1 = dims += 3;
  434.             ex = 1;
  435.             for(n = 1; n++ < nd; dims++) {
  436.                 if (ch != ',')
  437.                     errfl(a->cierr, 115, where);
  438.                 dn1 = dn + 1;
  439.                 span /= *dims;
  440.                 if (k = getdimen(&ch, dn1, dn->delta**dims,
  441.                         span, &b1))
  442.                     errfl(a->cierr, k, where);
  443.                 ex *= *dims;
  444.                 b += b1*ex;
  445.                 no *= dn1->extent;
  446.                 dn = dn1;
  447.                 }
  448.             if (ch != ')')
  449.                 errfl(a->cierr, 115, where);
  450.             b -= b0;
  451.             if (b < 0 || b >= nomax)
  452.                 errfl(a->cierr, 125, where);
  453.             iva += size * b;
  454.             dims = dims1;
  455.             while(GETC(ch) <= ' ' && ch >= 0);
  456.             no1 = 1;
  457.             dn0 = dimens;
  458.             if (type == TYCHAR && ch == '(' /*)*/) {
  459.                 if (k = getdimen(&ch, &substr, size, size, &b))
  460.                     errfl(a->cierr, k, where);
  461.                 if (ch != ')')
  462.                     errfl(a->cierr, 115, where);
  463.                 b1 = substr.extent;
  464.                 if (--b < 0 || b + b1 > size)
  465.                     return 124;
  466.                 iva += b;
  467.                 b0 = size;
  468.                 size = b1;
  469.                 while(GETC(ch) <= ' ' && ch >= 0);
  470.                 if (b1 < b0)
  471.                     goto delta_adj;
  472.                 }
  473.             for(; dn0 < dn; dn0++) {
  474.                 if (dn0->extent != *dims++ || dn0->stride != 1)
  475.                     break;
  476.                 no1 *= dn0->extent;
  477.                 }
  478.             if (dn0 == dimens && dimens[0].stride == 1) {
  479.                 no1 = dimens[0].extent;
  480.                 dn0++;
  481.                 }
  482.  delta_adj:
  483.             ex = 0;
  484.             for(dn1 = dn0; dn1 <= dn; dn1++)
  485.                 ex += (dn1->extent-1)
  486.                     * (dn1->delta *= dn1->stride);
  487.             for(dn1 = dn; dn1 > dn0; dn1--) {
  488.                 ex -= (dn1->extent - 1) * dn1->delta;
  489.                 dn1->delta -= ex;
  490.                 }
  491.             }
  492.         else if (dims = v->dims) {
  493.             no = no1 = dims[1];
  494.             ivae = iva + no*size;
  495.             }
  496.         else
  497.  scalar:
  498.             no = no1 = 1;
  499.         if (ch != '=')
  500.             errfl(a->cierr, 115, where);
  501.         got1 = nml_read = 1;
  502.         f__lcount = 0;
  503.      readloop:
  504.         for(;;) {
  505.             if (iva >= ivae || iva < 0) {
  506.                 f__lquit = 1;
  507.                 goto mustend;
  508.                 }
  509.             else if (iva + no1*size > ivae)
  510.                 no1 = (ivae - iva)/size;
  511.             f__lquit = 0;
  512.             if (k = l_read(&no1, vaddr + iva, size, type))
  513.                 return k;
  514.             if (f__lquit == 1)
  515.                 return 0;
  516.  mustend:
  517.             if (GETC(ch) == '/' || ch == '$' || ch == '&') {
  518.                 f__lquit = 1;
  519.                 return 0;
  520.                 }
  521.             else if (f__lquit) {
  522.                 while(ch <= ' ' && ch >= 0)
  523.                     GETC(ch);
  524.                 Ungetc(ch,f__cf);
  525.                 if (!Alpha[ch & 0xff] && ch >= 0)
  526.                     errfl(a->cierr, 125, where);
  527.                 break;
  528.                 }
  529.             Ungetc(ch,f__cf);
  530.             if ((no -= no1) <= 0)
  531.                 break;
  532.             for(dn1 = dn0; dn1 <= dn; dn1++) {
  533.                 if (++dn1->curval < dn1->extent) {
  534.                     iva += dn1->delta;
  535.                     goto readloop;
  536.                     }
  537.                 dn1->curval = 0;
  538.                 }
  539.             break;
  540.             }
  541.         }
  542.     }
  543.  
  544.  integer
  545. #ifdef KR_headers
  546. s_rsne(a) cilist *a;
  547. #else
  548. s_rsne(cilist *a)
  549. #endif
  550. {
  551.     extern int l_eof;
  552.     int n;
  553.  
  554.     f__external=1;
  555.     l_eof = 0;
  556.     if(n = c_le(a))
  557.         return n;
  558.     if(f__curunit->uwrt && f__nowreading(f__curunit))
  559.         err(a->cierr,errno,where0);
  560.     l_getc = t_getc;
  561.     l_ungetc = un_getc;
  562.     f__doend = xrd_SL;
  563.     n = x_rsne(a);
  564.     nml_read = 0;
  565.     if (n)
  566.         return n;
  567.     return e_rsle();
  568.     }
  569.